home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacGofer 0.22d / MacGofer Sources / storage.h < prev    next >
Encoding:
Text File  |  1994-01-06  |  22.2 KB  |  438 lines  |  [TEXT/MPS ]
  1.  */
  2. #endif
  3.  
  4. #define textOf(c)    ((Text)(snd(c)))
  5. #define intValOf(c)    (snd(c))
  6. #define mkVar(t)    ap(VARIDCELL,t)
  7. #define mkVarop(t)    ap(VAROPCELL,t)
  8. #define inventVar()    mkVar(inventText())
  9. #define mkDictVar(t)    ap(DICTVAR,t)
  10. #define inventDictVar() mkDictVar(inventDictText())
  11. #define mkStr(t)    ap(STRCELL,t)
  12. extern    Bool        isVar     Args((Cell));
  13. extern    Bool        isCon     Args((Cell));
  14. extern  Cell        openFile  Args((String));
  15. extern  Void        evalFile  Args((Cell));
  16.  
  17. #define isFloat(c)      (isPair(c) && fst(c)==FLOATCELL)
  18. extern    Cell        mkFloat        Args((FloatPro));
  19. extern  FloatPro    floatOf        Args((Cell));
  20. extern  String        floatToString   Args((FloatPro));
  21. extern  FloatPro    stringToFloat   Args((String));
  22. #if BREAK_FLOATS
  23. extern  Cell        part1Float    Args((FloatPro));
  24. extern  Cell        part2Float    Args((FloatPro));
  25. extern  FloatPro    floatFromParts    Args((Cell,Cell));
  26. #endif
  27.  
  28. /* --------------------------------------------------------------------------
  29.  * Constructor cell tags are used as the fst element of a pair to indicate
  30.  * a particular syntactic construct described by the snd element of the
  31.  * pair.
  32.  * Note that a cell c will not be treated as an application (AP/isAp) node
  33.  * if its first element is a constructor cell tag, whereas a cell whose fst
  34.  * element is a special cell will be treated as an application node.
  35.  * ------------------------------------------------------------------------*/
  36.  
  37. #define LETREC         20       /* LETREC    snd :: ([Decl],Exp)       */
  38. #define COND         21       /* COND    snd :: (Exp,Exp,Exp)       */
  39. #define LAMBDA         22       /* LAMBDA    snd :: Alt           */
  40. #define FINLIST      23       /* FINLIST    snd :: [Exp]           */
  41. #define COMP         24          /* COMP    snd :: (Exp,[Qual])       */
  42. #define LISTCOMP     25       /* LISCOMP    snd :: (Exp,[Qual])       */
  43. #define MONADCOMP    26          /* MONADCOMP  snd :: (dicts,(Exp,[Qual]))*/
  44. #define ASPAT         27       /* ASPAT    snd :: (Var,Exp)       */
  45. #define ESIGN         28       /* ESIGN    snd :: (Exp,Type)       */
  46. #define CASE         29       /* CASE    snd :: (Exp,[Alt])       */
  47. #define FATBAR         30       /* FATBAR    snd :: (Exp,Exp)       */
  48. #define LAZYPAT      31       /* LAZYPAT    snd :: Exp           */
  49. #define QUAL         32       /* QUAL       snd :: ([Classes],Type)    */
  50. #if BREAK_FLOATS
  51. #define FLOATCELL    33          /* FLOATCELL  snd :: (Int,Int)       */
  52. #endif
  53.  
  54. #define BOOLQUAL     36       /* BOOLQUAL    snd :: Exp           */
  55. #define QWHERE         37       /* QWHERE    snd :: [Decl]           */
  56. #define FROMQUAL     38       /* FROMQUAL    snd :: (Exp,Exp)       */
  57.  
  58. #define GUARDED      39       /* GUARDED    snd :: [guarded exprs]       */
  59.  
  60. #define POLYTYPE     45          /* POLYTYPE    snd :: (Kind,Type)       */
  61.  
  62. #define C_TOPARG     50          /* Compiler instruction codes:       */
  63. #define C_TOPFUN     51          /* see cmachine.c for further details       */
  64. #define C_SETSTK     52
  65. #define C_EVAL         53
  66. #define C_LABEL      54
  67. #define C_GOTO         55
  68. #define C_FLUSH         56
  69. #define C_UPDAP2     57
  70. #define C_HEAP         58
  71.  
  72. #define C_PUSHPAIR   60
  73. #define C_UPDATE     61
  74. #define C_SLIDE         62
  75. #define C_INTEQ         63
  76. #define C_TEST         64
  77.  
  78. #define C_UPDAP         70
  79. #define C_INTGE      71
  80. #define C_INTDV      72
  81.  
  82. #define BRANCH         80           /* Code generator continuation structures*/
  83. #define FBRANCH         81          /* see cmachine.c for further details    */
  84.  
  85. /* --------------------------------------------------------------------------
  86.  * Special cell values:
  87.  * ------------------------------------------------------------------------*/
  88.  
  89. #define SPECMIN      101
  90. #define isSpec(c)    (SPECMIN<=(c) && (c)<TUPMIN)/* Special cell values    */
  91.  
  92. #define UNIT         101      /* Unit type/value denoted ()        */
  93. #define STAR         102      /* Representing the kind of types       */
  94. #define LIST         103      /* Builtin list type constructor       */
  95. #define ARROW         104      /* Builtin function space constructor    */
  96. #define WILDCARD     105      /* Wildcard pattern               */
  97.  
  98. #define NAME         110      /* whatIs code for isName           */
  99. #define TYCON         111      /* whatIs code for isTycon           */
  100. #define CLASS         112      /* whatIs code for isClass           */
  101. #define SELECT       113          /* whatIs code for isSelect              */
  102. #define INSTANCE     114          /* whatIs code for isInst                */
  103. #define TUPLE         115      /* whatIs code for tuple constructor       */
  104. #define OFFSET         116      /* whatis code for offset           */
  105. #define AP         117      /* whatIs code for application node       */
  106. #define CHARCELL     118      /* whatIs code for isChar           */
  107.  
  108. #define SIGDECL      120      /* Signature declaration           */
  109. #define CFUN         121      /* Indicates name acting as constr fun   */
  110. #define MFUN         122      /* Indicates name acting as member fun   */
  111. #define PRIM         123      /* indicates name defined by primitive   */
  112. #define UNDEFINED    124      /* indicates name with syntax but no defn*/
  113. #define PREDEFINED   125      /* predefined name, not yet filled       */
  114. #define NEEDED       126      /* marks name as needed supercombinator  */
  115.  
  116. #define DATATYPE     130      /* datatype type constructor           */
  117. #define SYNONYM         131      /* synonym type constructor           */
  118. #define RESTRICTSYN  132      /* synonym with restricted scope       */
  119.  
  120. #define NODEPENDS    135      /* stop calculation of deps in type check*/
  121.  
  122. #define TOP         140      /* refers to top of stack in cmachine.c  */
  123. #define POP         141      /* like TOP above, but remove from stack */
  124.  
  125. #define ROOTFST         145      /* represents func to move down from root*/
  126.  
  127. #define C_MKAP         150          /* Compiler instruction codes:       */
  128. #define C_ALLOC         151      /* see cmachine.c for further details       */
  129. #define C_RETURN     152
  130.  
  131. #define ERRCONT         160      /* Code generator continuation structures*/
  132. #define RUNONC         161      /* see cmachine.c for further details    */
  133. #define FRUNONC         162
  134. #define UPDRETC         163
  135.  
  136. #define fn(from,to)  pair(pair(ARROW,from),to)     /* make type:    from -> to */
  137.  
  138. /* --------------------------------------------------------------------------
  139.  * Tuple data/type constructors:
  140.  * ------------------------------------------------------------------------*/
  141.  
  142. #define TUPMIN         201
  143. #define isTuple(c)   (TUPMIN<=(c) && (c)<OFFMIN)
  144. #define mkTuple(n)   (TUPMIN+(n))
  145. #define tupleOf(n)   ((Int)((n)-TUPMIN))
  146.  
  147. /* --------------------------------------------------------------------------
  148.  * Offsets: (generic types/stack offsets)
  149.  * ------------------------------------------------------------------------*/
  150.  
  151. #define OFFMIN         (TUPMIN+num_tuples)
  152. #define isOffset(c)  (OFFMIN<=(c) && (c)<TYCMIN)
  153. #define offsetOf(c)  ((c)-OFFMIN)
  154. #define mkOffset(o)  (OFFMIN+(o))
  155.  
  156. /* --------------------------------------------------------------------------
  157.  * Type constructor names:
  158.  * ------------------------------------------------------------------------*/
  159.  
  160. #define TYCMIN         (OFFMIN+num_offsets)
  161. #define isTycon(c)   (TYCMIN<=(c) && (c)<NAMEMIN)
  162. #define mkTycon(n)   (TCMIN+(n))
  163. #define tycon(n)     tabTycon[(n)-TYCMIN]
  164.  
  165. struct Tycon {
  166.     Text  text;
  167.     Int   line;
  168.     Int   arity;
  169.     Kind  kind;                /* kind (includes arity) of Tycon  */
  170.     Cell  what;                /* DATATYPE/SYNONYM/RESTRICTSYN... */
  171.     Cell  defn;
  172.     Tycon nextTyconHash;
  173. };
  174.  
  175. #if DYNAMIC_STORAGE
  176. extern struct Tycon *tabTycon;
  177. #else
  178. extern struct Tycon tabTycon[];
  179. #endif
  180.  
  181. extern Tycon newTycon      Args((Text));
  182. extern Tycon findTycon      Args((Text));
  183. extern Tycon addPrimTycon Args((String,Kind,Cell,Cell));
  184.  
  185. #define isSynonym(h)    (isTycon(h) && tycon(h).what==SYNONYM)
  186. #define mkPolyType(n,t)    pair(POLYTYPE,pair(n,t))
  187. #define isPolyType(t)    (isPair(t) && fst(t)==POLYTYPE)
  188. #define polySigOf(t)    fst(snd(t))
  189. #define monoTypeOf(t)    snd(snd(t))
  190.  
  191. /* --------------------------------------------------------------------------
  192.  * Globally defined name values:
  193.  * ------------------------------------------------------------------------*/
  194.  
  195. #define NAMEMIN      (TYCMIN+num_tycon)
  196. #define isName(c)    (NAMEMIN<=(c) && (c)<SELMIN)
  197. #define mkName(n)    (NAMEMIN+(n))
  198. #if THINKC
  199. #define name(n)      (*(tabName+((n)-NAMEMIN)))
  200. #else
  201. #define name(n)      tabName[(n)-NAMEMIN]
  202. #endif
  203.  
  204. struct Name {
  205.     Text text;
  206.     Int  line;
  207.     Int  arity;
  208.     Int  number;     /* UNDEFINED : line number of first use           */
  209.              /* CFUN      : constructor number (e.g. Nil=0,Cons=1) */
  210.              /* MFUN      : member number (offset into Dict!)       */
  211.     Cell type;
  212.     Cell defn;
  213.     Addr code;
  214.     Prim primDef;
  215.     Name nextNameHash;
  216. };
  217.  
  218. #if DYNAMIC_STORAGE
  219. extern struct Name *tabName;
  220. #else
  221. extern struct Name tabName[];
  222. #endif
  223.  
  224. extern Name newName    Args((Text));
  225. extern Name findName    Args((Text));
  226. extern Void addPrim    Args((Int,Name,String,Type));
  227. extern Name addPrimCfun Args((String,Int,Int,Cell));
  228.  
  229. /* --------------------------------------------------------------------------
  230.  * Type class values:
  231.  * ------------------------------------------------------------------------*/
  232.  
  233. #define SELMIN       (NAMEMIN+num_name)          /* dictionary selectors   */
  234. #define isSelect(c)  (SELMIN<=(c) && (c)<INSTMIN)
  235. #define mkSelect(n)  (SELMIN+(n))
  236. #define selectOf(c)  ((Int)((c)-SELMIN))
  237.  
  238. #define INSTMIN      (SELMIN+num_selects)        /* instances              */
  239. #define isInst(c)    (INSTMIN<=(c) && (c)<CLASSMIN)
  240. #define mkInst(n)    (INSTMIN+(n))
  241. #define inst(in)     tabInst[(in)-INSTMIN]
  242.  
  243. struct Inst {
  244.     Class cl;
  245.     Int   line;
  246.     Kind  sig;                /* kinds of variables in header       */
  247.     Cell  head;                /* :: Pred               */
  248.     List  specifics;            /* :: [Pred]               */
  249.     Int   numSpecifics;            /* length(specifics)           */
  250.     List  implements;
  251. };
  252.  
  253. /* a predicate (an element :: Pred) is an application of a Class to one or
  254.  * more type expressions
  255.  */
  256.  
  257. #define CLASSMIN     (INSTMIN+num_insts)
  258. #define isClass(c)   (CLASSMIN<=(c) && (c)<CHARMIN)
  259. #define mkClass(n)   (CLASSMIN+(n))
  260. #define class(n)     tabClass[(n)-CLASSMIN]
  261.  
  262. struct Class {
  263.     Text text;                /* Name of class           */
  264.     Int  line;
  265.     Int  arity;
  266.     Kind sig;                /* Sig ::= NIL | (Kind,Sig)       */
  267.     Cell head;                /* :: Pred               */
  268.     List supers;            /* :: [Pred]               */
  269.     Int  numSupers;            /* length(supers)           */
  270.     List members;            /* :: [Name]               */
  271.     Int  numMembers;            /* length(members)           */
  272.     List defaults;            /* :: [Name]               */
  273.     List instances;            /* :: [Inst]               */
  274.     Idx  dictIndex;
  275. };
  276.  
  277. struct Idx {
  278.     Cell test;
  279.     Idx  fail;
  280.     Idx  match;      /* may also be used as a Dict value ... */
  281. };
  282. #define NOIDX         ((Idx)(-1))
  283. #define NODICT         ((Dict)(-1))
  284.  
  285. #if DYNAMIC_STORAGE
  286. extern struct Class    *tabClass;
  287. #else
  288. extern struct Class    tabClass[];
  289. #endif
  290.  
  291. extern struct Inst far *tabInst;
  292. extern struct Idx  far *tabIndex;
  293. extern Cell       far *tabDict;
  294.  
  295. #define idx(ix)        tabIndex[ix]
  296. #define dict(at)       tabDict[at]
  297. #define dictOf(c)      ((Dict)(snd(c)))
  298. #define mkDict(d)      ap(DICTCELL,d)
  299.  
  300. extern Class newClass  Args((Text));
  301. extern Class findClass Args((Text));
  302. extern Inst  newInst   Args((Void));
  303. extern Idx   newIdx    Args((Cell));
  304. extern Dict  newDict   Args((Int));
  305.  
  306. /* --------------------------------------------------------------------------
  307.  * Character values:
  308.  * ------------------------------------------------------------------------*/
  309.  
  310. #define CHARMIN      (CLASSMIN+num_classes)
  311. #define MAXCHARVAL   (NUM_CHARS-1)
  312. #define isChar(c)    (CHARMIN<=(c) && (c)<INTMIN)
  313. #define charOf(c)    ((Char)(c-CHARMIN))
  314. #define mkChar(c)    ((Cell)(CHARMIN+((unsigned)((c)%NUM_CHARS))))
  315.  
  316. /* --------------------------------------------------------------------------
  317.  * Small Integer values:
  318.  * ------------------------------------------------------------------------*/
  319.  
  320. #define INTMIN         (CHARMIN+NUM_CHARS)
  321. #define INTMAX         MAXPOSINT
  322. #define isSmall(c)   (INTMIN<=(c))
  323. #define INTZERO      (INTMIN/2 + INTMAX/2)
  324.  
  325. extern    Bool isInt   Args((Cell));
  326. extern    Int  intOf   Args((Cell));
  327. extern    Cell mkInt   Args((Int));
  328.  
  329. /* --------------------------------------------------------------------------
  330.  * Implementation of triples:
  331.  * ------------------------------------------------------------------------*/
  332.  
  333. #define triple(x,y,z) pair(x,pair(y,z))
  334. #define fst3(c)      fst(c)
  335. #define snd3(c)      fst(snd(c))
  336. #define thd3(c)      snd(snd(c))
  337.  
  338. /* --------------------------------------------------------------------------
  339.  * Implementation of lists:
  340.  * ------------------------------------------------------------------------*/
  341.  
  342. #define NIL         0
  343. #define isNull(c)    ((c)==NIL)
  344. #define nonNull(c)   (c)
  345. #define cons(x,xs)   pair(x,xs)
  346. #define singleton(x) cons(x,NIL)
  347. #define hd(c)         fst(c)
  348. #define tl(c)         snd(c)
  349.  
  350. extern    Int         length      Args((List));
  351. extern    List         appendOnto   Args((List,List));
  352. extern    List         revOnto      Args((List, List));
  353. #define rev(xs)      revOnto((xs),NIL)
  354.  
  355. extern    Cell         cellIsMember Args((Cell,List));
  356. extern    Cell         varIsMember  Args((Text,List));
  357. extern    List         copy      Args((Int,Cell));
  358. extern    List         diffList      Args((List,List));
  359. extern  List         take      Args((Int,List));
  360. extern  List         removeCell      Args((Cell,List));
  361.  
  362. /* The following macros provide `inline expansion' of some common ways of
  363.  * traversing, using and modifying lists:
  364.  *
  365.  * N.B. We use the names _f, _a, _xs, Zs, in an attempt to avoid clashes
  366.  *    with identifiers used elsewhere.
  367.  */
  368.  
  369. #define mapBasic(_init,_step)      {List Zs=(_init);\
  370.                    for(;nonNull(Zs);Zs=tl(Zs))\
  371.                    _step;}
  372. #define mapModify(_init,_step)      mapBasic(_init,hd(Zs)=_step)
  373.  
  374. #define mapProc(_f,_xs)       mapBasic(_xs,_f(hd(Zs)))
  375. #define map1Proc(_f,_a,_xs)      mapBasic(_xs,_f(_a,hd(Zs)))
  376. #define map2Proc(_f,_a,_b,_xs)      mapBasic(_xs,_f(_a,_b,hd(Zs)))
  377. #define map3Proc(_f,_a,_b,_c,_xs) mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
  378.  
  379. #define mapOver(_f,_xs)       mapModify(_xs,_f(hd(Zs)))
  380. #define map1Over(_f,_a,_xs)      mapModify(_xs,_f(_a,hd(Zs)))
  381. #define map2Over(_f,_a,_b,_xs)      mapModify(_xs,_f(_a,_b,hd(Zs)))
  382. #define map3Over(_f,_a,_b,_c,_xs) mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
  383.  
  384. /* --------------------------------------------------------------------------
  385.  * Implementation of function application nodes:
  386.  * ------------------------------------------------------------------------*/
  387.  
  388. #define ap(f,x)      pair(f,x)
  389. #define fun(c)         fst(c)
  390. #define arg(c)         snd(c)
  391. #define isAp(c)      (isPair(c) && !isTag(fst(c)))
  392. extern    Cell         getHead     Args((Cell));
  393. extern    List         getArgs     Args((Cell));
  394. extern    Int         argCount;
  395. extern  Cell         nthArg     Args((Int,Cell));
  396. extern  Int         numArgs     Args((Cell));
  397. extern  Cell         applyToArgs Args((Cell,List));
  398.  
  399. /* --------------------------------------------------------------------------
  400.  * Stack implementation:
  401.  * ------------------------------------------------------------------------*/
  402.  
  403. #if DYNAMIC_STORAGE
  404. extern    Cell         *cellStack;
  405. #else
  406. extern    Cell         cellStack[];
  407. #endif
  408.  
  409. #ifdef  GLOBALsp
  410. register StackPtr    sp GLOBALsp;
  411. #else
  412. extern    StackPtr     sp;
  413. #endif
  414. #define clearStack() sp=(-1)
  415. #define stackEmpty() (sp==(-1))
  416. #define stack(p)     cellStack[p]
  417. #define chkStack(n)  if (sp>=num_stack-n) stackOverflow()
  418. #define push(c)      chkStack(1); onto(c)
  419. #define onto(c)         stack(++sp)=(c)
  420. #define pop()         stack(sp--)
  421. #define drop()         sp--
  422. #define top()         stack(sp)
  423. #define pushed(n)    stack(sp-(n))
  424.  
  425. extern Void         stackOverflow Args((Void));
  426.  
  427. /* --------------------------------------------------------------------------
  428.  * Module control:
  429.  * The implementation of `module' storage is hidden.
  430.  * ------------------------------------------------------------------------*/
  431.  
  432. extern Module       startNewModule  Args((Void));
  433. extern Bool        nameThisModule  Args((Name));
  434. extern Module       moduleThisName  Args((Name));
  435. extern Void       dropModulesFrom Args((Module));
  436.  
  437. /*-------------------------------------------------------------------------*/
  438.